home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / opt / expand.scm < prev    next >
Text File  |  1995-10-13  |  8KB  |  290 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Front end for Scheme 48 compilation, optimization, or whatever.
  5.  
  6. ; Entry point for debugging or casual use.
  7.  
  8. (define (expand-form form p)
  9.   (let-fluid $assignments #f
  10.     (lambda ()
  11.       (expand-begin (scan-forms (list form) p #f)
  12.             (package->environment p)))))
  13.  
  14.  
  15. ; After processing a package body, we change the types of all
  16. ; unassigned top-level variables from (VARIABLE <type>) to <type>.
  17.  
  18. (define (expand-stuff stuff p)
  19.   (let* ((table (make-table))
  20.      (env (package->environment p))
  21.      (new-stuff
  22.       (let-fluid $assignments (cons p table)
  23.         (lambda ()
  24.           (map (lambda (filename+nodes)
  25.              (let ((filename (car filename+nodes))
  26.                (nodes (cdr filename+nodes)))
  27.                (cons filename
  28.                  (let ((env (bind-source-file-name filename env)))
  29.                    (map (lambda (node)
  30.                       (expand node env))
  31.                     nodes)))))
  32.            stuff)))))
  33.     (for-each (lambda (filename+nodes)
  34.         (for-each (lambda (node)
  35.                 (if (define-node? node)
  36.                 (maybe-update-known-type node p table)))
  37.               (cdr filename+nodes)))
  38.           new-stuff)
  39.     new-stuff))
  40.  
  41. (set-optimizer! 'expand expand-stuff)
  42.  
  43. (define (maybe-update-known-type node p table)
  44.   (let ((lhs (cadr (node-form node))))
  45.     (if (not (table-ref table lhs))
  46.     (let ((new-type (reconstruct-type (caddr (node-form node))
  47.                       (package->environment p))))
  48.       (if (subtype? new-type any-values-type)
  49.           (package-define! p lhs (if (subtype? new-type value-type)
  50.                      new-type
  51.                      value-type))
  52.           (warn "ill-typed right-hand side"
  53.             (schemify node)
  54.             (type->sexp new-type #t)))))))
  55.  
  56. (define lambda-node? (node-predicate 'lambda))
  57.  
  58.  
  59. ; --------------------
  60. ; Expand a single form.
  61.  
  62. (define (expand form env)
  63.   (let ((node (classify form env)))
  64.     (if (already-expanded? node)
  65.     node
  66.     ((get-expander (node-operator-id node)) node env))))
  67.  
  68. (define expanders
  69.   (make-operator-table (lambda (node env)
  70.              (let ((form (node-form node)))
  71.                (make-expanded node
  72.                       (cons (car form)
  73.                         (map (lambda (arg-exp)
  74.                                (expand arg-exp env))
  75.                              (cdr form))))))))
  76.  
  77. (define (define-expander name type proc)
  78.   (operator-define! expanders name type proc))
  79.  
  80. (define (get-expander id)
  81.   (operator-table-ref expanders id))
  82.  
  83. (define-expander 'literal #f
  84.   (lambda (node env)
  85.     (set-expanded node)))
  86.  
  87. (define-expander 'name #f
  88.   (lambda (node env)
  89.     (note-reference! node)
  90.     node))
  91.  
  92. (define-expander 'call #f
  93.   (lambda (node env)
  94.     (let ((exp (node-form node)))
  95.       (let ((proc-node (expand (car exp) env)))
  96.     (note-operator! proc-node)
  97.     (make-expanded node
  98.                (cons proc-node
  99.                  (map (lambda (arg-exp)
  100.                     (expand arg-exp env))
  101.                   (cdr exp))))))))
  102.  
  103.  
  104. ; Special operators
  105.  
  106. (define-expander 'quote syntax-type
  107.   (lambda (node env)
  108.     (set-expanded node)))
  109.  
  110. (define-expander 'lambda syntax-type
  111.   (lambda (node env)
  112.     (set-fluid! $inferior-lambdas? #t)
  113.     (let-fluid $inferior-lambdas? #f
  114.       (lambda ()
  115.     (let* ((exp (node-form node))
  116.            (formals (cadr exp)))
  117.       (with-lexicals (normalize-formals formals) env
  118.         (lambda (env lexicals)
  119.           (let ((node (make-expanded node
  120.                      (list (car exp)
  121.                            formals
  122.                            (expand-body (cddr exp) env)))))
  123.         (if (not (fluid $inferior-lambdas?))
  124.             (node-set! node 'no-inferior-lambdas #t))
  125.         node))))))))
  126.  
  127. (define with-lexicals
  128.   (let ((operator/name (get-operator 'name)))
  129.     (lambda (vars env proc)
  130.       (let* ((lexicals (map make-lexical vars))
  131.          (var-nodes (map (lambda (formal lexical)
  132.                    (let ((var-node
  133.                       (make-node operator/name formal)))
  134.                  (node-set! var-node 'lexical lexical)
  135.                  var-node))
  136.                  vars
  137.                  lexicals))
  138.          (node (proc (bind vars var-nodes env) lexicals)))
  139.     (node-set! node 'var-nodes var-nodes)
  140.     node))))
  141.  
  142.  
  143. (define-expander 'letrec syntax-type
  144.   (lambda (node env)
  145.     (set-fluid! $inferior-lambdas? #t)    ;foo
  146.     (let* ((exp (node-form node))
  147.        (specs (cadr exp))
  148.        (body (cddr exp)))
  149.       (with-lexicals (map car specs) env
  150.     (lambda (env lexicals)
  151.       (let* ((specs (map (lambda (spec)
  152.                    (list (car spec)
  153.                      (expand (cadr spec) env)))
  154.                  specs))
  155.          (node (make-expanded node
  156.                       (list (car exp)
  157.                         specs
  158.                         (expand-body body env)))))
  159.         (if (and (every (lambda (spec)
  160.                   (lambda-node? (cadr spec)))
  161.                 specs)
  162.              (every (lambda (lexical)
  163.                   (and (= (lexical-assignment-count lexical) 0)
  164.                    (= (lexical-reference-count lexical)
  165.                       (lexical-operator-count lexical))))
  166.                 lexicals))
  167.         (node-set! node 'pure-letrec #t))
  168.         node))))))
  169.  
  170. (define $inferior-lambdas? (make-fluid #t))
  171.  
  172. (define expand-body
  173.   (let ((operator/letrec (get-operator 'letrec syntax-type)))
  174.     (lambda (body env)
  175.       (scan-body body
  176.          env
  177.          (lambda (defs exps)    ;defs is a list of define nodes
  178.            (if (null? defs)
  179.                (expand-begin exps env)
  180.                (expand (make-node
  181.                    operator/letrec
  182.                    `(letrec ,(map (lambda (def)
  183.                             (cdr (node-form def)))
  184.                           defs)
  185.                       ,@exps))
  186.                    env)))))))
  187.  
  188. (define expand-begin
  189.   (let ((op (get-operator 'begin syntax-type)))
  190.     (lambda (exp-list env)
  191.       (let ((nodes (map (lambda (exp) (expand exp env))
  192.             exp-list)))
  193.     (if (null? (cdr nodes))
  194.         (car nodes)
  195.         (set-expanded (make-node op (cons 'begin nodes))))))))
  196.  
  197. (define-expander 'set! syntax-type
  198.   (lambda (node env)
  199.     (let ((exp (node-form node)))
  200.       (let ((lhs (classify (cadr exp) env))
  201.         (rhs (expand (caddr exp) env)))
  202.     (if (name-node? lhs)
  203.         (begin (if (node-ref lhs 'lexical)
  204.                (note-assignment! lhs)
  205.                (note-top-level-assignment! (node-form lhs)))
  206.            (make-expanded node (list (car exp) lhs rhs)))
  207.         (expand (syntax-error "invalid assignment" (node-form node))
  208.             env))))))
  209.  
  210. (define name-node? (node-predicate 'name 'leaf))
  211.  
  212. (define (name-node-binding node cenv)
  213.   (or (node-ref node 'binding)
  214.       (lookup cenv (node-form node))))
  215.  
  216. (define-expander 'define syntax-type
  217.   (lambda (node env)
  218.     (let ((form (node-form node)))
  219.       (make-expanded node
  220.              (list (car form)
  221.                (cadr form)
  222.                (expand (caddr form) env))))))
  223.  
  224. (define-expander 'if syntax-type
  225.   (lambda (node env)
  226.     (let ((exp (node-form node)))
  227.       (make-expanded node
  228.              (list (car exp)
  229.                (expand (cadr exp) env)
  230.                (expand (caddr exp) env)
  231.                (expand (cadddr exp) env))))))
  232.  
  233. (define-expander 'primitive-procedure syntax-type
  234.   (lambda (node env)
  235.     (set-expanded node)))
  236.  
  237.  
  238. ; --------------------
  239. ; Expanded nodes
  240.  
  241. (define (make-expanded node form)
  242.   (set-expanded (make-similar-node node form)))
  243.  
  244. (define (set-expanded node)
  245.   (node-set! node 'expanded #t)
  246.   node)
  247.  
  248. (define (already-expanded? node)
  249.   (node-ref node 'expanded))
  250.  
  251. ; --------------------
  252. ; Keep track of which defined top-level variables are assigned
  253.  
  254. (define $assignments (make-fluid #f))
  255.  
  256. (define (note-top-level-assignment! name)
  257.   (let ((package+table (fluid $assignments)))
  258.     (if package+table
  259.     (if (generated? name)
  260.         (if (eq? (generated-env name) (car package+table))
  261.         (table-set! (cdr package+table) (generated-symbol name) #t))
  262.         (table-set! (cdr package+table) name #t)))))
  263.  
  264.  
  265. ; --------------------
  266. ; Lexical information structures record the number of times that a
  267. ; variable is used.
  268.  
  269. (define (make-lexical name)
  270.   (vector 0 0 0))
  271.  
  272. (define (lexical-accessor j)
  273.   (lambda (lex)
  274.     (vector-ref lex j)))
  275.  
  276. (define (lexical-incrementator j)
  277.   (lambda (node)
  278.     (let ((v (node-ref node 'lexical)))
  279.       (if v
  280.       (vector-set! v j (+ (vector-ref v j) 1))))))
  281.  
  282. (define lexical-reference-count  (lexical-accessor 0))
  283. (define lexical-operator-count   (lexical-accessor 1))
  284. (define lexical-assignment-count (lexical-accessor 2))
  285.  
  286. (define note-reference!  (lexical-incrementator 0))
  287. (define note-operator!   (lexical-incrementator 1))
  288. (define note-assignment! (lexical-incrementator 2))
  289.  
  290.